Sub CreateAccessDB()
Dim str1 As String

'Specify the name of the new database
str1 = "C:\LunarSociety\NewDB.mdb"

'Check for duplicate database name and handle error
On Error GoTo CreateAccessDBErrorTrap
Dim cat1 As New ADOX.Catalog

'Instantiate the new catalog
Set cat1 = New ADOX.Catalog

'Create the new database
cat1.Create "Provider=Microsoft.Jet.OLEDB.4.0;" _
     & "Data Source=" & str1

CreateAccessDBExit:
'Clean up before exiting
Set cat1 = Nothing
Exit Sub

CreateAccessDBErrorTrap:
If Err.Number = -2147217897 Then
'If a prior version of this DB exists, kill it
     Debug.Print str1
     Kill (str1)
     Resume
Else
'If a different error has occurred display its description
     Debug.Print Err.Number, Err.Description
     MsgBox "Check Immediate window for error information.", _
          vbInformation
End If
    
End Sub
